Delphi Magazine Collection 2001/Delphi Magazine Collection 20001 (2001).iso/DISKS/Issue31/bcolorbt/BCOLORBT.ZIP/CBtnForm.pas

Pascal/Delphi Source File | 1998-02-06 | 20.8 KB | 781 lines

{.$DEFINE FIX_STREAM_ERROR}

{$I DFS.INC}  { Standard defines for all Delphi Free Stuff components }

{-----------------------------------------------------------------------------}
{ A Windows 95 and NT 4 style color selection button.  It displays a palette  }
{ of 20 color for fast selction and a button to bring up the color dialog.    }
{ Copyright 1996, Brad Stowers.  All Rights Reserved.                         }
{ This component can be freely used and distributed in commercial and private }
{ environments, provied this notice is not modified in any way and there is   }
{ no charge for it other than nomial handling fees.  Contact me directly for  }
{ modifications to this agreement.                                            }
{-----------------------------------------------------------------------------}
{ Feel free to contact me if you have any questions, comments or suggestions  }
{ at [e-mail].                                                      }
{ The lateset version will always be available on the web at:                 }
{   http://www.pobox.com/~bstowers/delphi/                                    }
{-----------------------------------------------------------------------------}
{ Date last modified:  February 5, 1998                                       }
{-----------------------------------------------------------------------------}


{-----------------------------------------------------------------------------}
{ TDFSColorButtonPalette                                                      }
{-----------------------------------------------------------------------------}
{ Description:                                                                }
{   This is a support unit for the TDFSColorButton component (COLORBTN.PAS).  }
{-----------------------------------------------------------------------------}
unit CBtnForm;

interface

uses
  WinTypes, WinProcs, Messages, SysUtils, Classes, Graphics, Controls, Forms,
  Dialogs, StdCtrls;

const
  MAX_COLORS = (MaxInt div SizeOf(TColor));

type
  TSetParentColorEvent = procedure(Sender: TObject; AColor: TColor) of object;

  EColorArrayIndexError = class(Exception);

  PColorArray = ^TColorArray;
  TColorArray = array[1..MAX_COLORS] of TColor;

  TColorArrayClass = class(TPersistent)
  private
    FXSize,
    FYSize: integer;
    FColors: PColorArray;

    function GetColor(X, Y: integer): TColor;
    procedure SetColor(X, Y: integer; Value: TColor);
    procedure SetXSize(Value: integer);
    procedure SetYSize(Value: integer);
    function GetSingleColor(Index: integer): TColor;
    procedure SetSingleColor(Index: integer; Value: TColor);
  protected
    procedure CheckXYVals(X, Y: integer);
{$IFDEF FIX_STREAM_ERROR}
    procedure ReadColorData(Stream: TStream);
    procedure WriteColorData(Stream: TStream);
{$ELSE}
    procedure ReadColors(Reader: TReader);
    procedure WriteColors(Writer: TWriter);
{$ENDIF}
  public
    constructor Create(X, Y: integer); virtual;
    destructor Destroy; override;
    procedure Assign(Source: TPersistent); override;
    procedure DefineProperties(Filer: TFiler); override;
    function IsEqualTo(OtherColors: TColorArrayClass): boolean; virtual;

    property Color[X: integer; Y: integer]: TColor
       read GetColor
       write SetColor;
       default;
    property Colors[Index: integer]: TColor
      read GetSingleColor
      write SetSingleColor;
{  published}
    property XSize: integer
       read FXSize
       write SetXSize;
    property YSize: integer
       read FYSize
       write SetYSize;
  end;

  TPaletteColors = TColorArrayClass;
  TCustomColors = TColorArrayClass;

  TDFSColorButtonPalette = class(TForm)
    btnOther: TButton;
    procedure FormClose(Sender: TObject; var Action: TCloseAction);
    procedure FormDeactivate(Sender: TObject);
    procedure FormPaint(Sender: TObject);
    procedure FormCreate(Sender: TObject);
    procedure btnOtherClick(Sender: TObject);
    procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean);
    procedure FormMouseMove(Sender: TObject; Shift: TShiftState; X,
      Y: Integer);
    procedure FormClick(Sender: TObject);
    procedure FormKeyPress(Sender: TObject; var Key: Char);
    procedure FormDestroy(Sender: TObject);
  private
    FPreventClose: boolean;
    FOldAppDeactivate: TNotifyEvent;
    FPaletteColors: TPaletteColors;
    FCustomColors: TCustomColors;
    FStartColor,
    FOtherColor: TColor;
    FLastFrame: TPoint;
    FSetParentColor: TSetParentColorEvent;
    FPaletteClosed: TNotifyEvent;

    function ValidColorIndex(X, Y: integer): boolean;
    procedure AppDeactivate(Sender: TObject);
    procedure DrawSquare(X, Y: integer; AColor: TColor; IsFocused: boolean);
    procedure FrameCurrentSquare;
    function GetCurrentSquare: TPoint;
    procedure SetStartColor(Value: TColor);
    procedure SetPaletteColors(Value: TPaletteColors);
    procedure SetCustomColors(Value: TCustomColors);
  protected
    procedure CreateParams(var Params: TCreateParams); override;
  public
    constructor Create(AOwner: TComponent); override;
    destructor Destroy; override;

    property SetParentColor: TSetParentColorEvent
       read FSetParentColor
       write FSetParentColor;
    property PaletteClosed: TNotifyEvent
       read FPaletteClosed
       write FPaletteClosed;
    property Color: TColor
       read FStartColor
       write SetStartColor;
    property OtherColor: TColor
       read FOtherColor
       write FOtherColor;
    property PaletteColors: TPaletteColors
       read FPaletteColors
       write SetPaletteColors;
    property CustomColors: TCustomColors
       read FCustomColors
       write SetCustomColors;
  end;


implementation

{$R *.DFM}


constructor TColorArrayClass.Create(X, Y: integer);
begin
  inherited Create;

  FXSize := X;
  FYSize := Y;
  GetMem(FColors, X * Y * SizeOf(TColor));
end;

destructor TColorArrayClass.Destroy;
begin
  FreeMem(FColors, FXSize * FYSize * SizeOf(TColor));

  inherited Destroy;
end;

function TColorArrayClass.GetColor(X, Y: integer): TColor;
begin
  CheckXYVals(X, Y);
  Result := FColors^[(Y-1)*FXSize+X];
end;

procedure TColorArrayClass.SetColor(X, Y: integer; Value: TColor);
begin
  CheckXYVals(X, Y);
  FColors^[(Y-1)*FXSize+X] := Value;
end;

procedure TColorArrayClass.SetXSize(Value: integer);
begin
  if Value <> XSize then
  begin
    FreeMem(FColors, XSize * YSize * SizeOf(TColor));
    FXSize := Value;
    GetMem(FColors, XSize * YSize * SizeOf(TColor));
    { really need to recopy colors, but I'm lazy and don't need it right now }
  end;
end;

procedure TColorArrayClass.SetYSize(Value: integer);
begin
  if Value <> YSize then
  begin
    FreeMem(FColors, XSize * YSize * SizeOf(TColor));
    FYSize := Value;
    GetMem(FColors, XSize * YSize * SizeOf(TColor));
    { really need to recopy colors, but I'm lazy and don't need it right now }
  end;
end;

function TColorArrayClass.GetSingleColor(Index: integer): TColor;
begin
  if (Index < 1) or (Index > (XSize * YSize)) then
    raise EColorArrayIndexError.Create('Array index out of bounds');
  Result := FColors^[Index];
end;

procedure TColorArrayClass.SetSingleColor(Index: integer; Value: TColor);
begin
  if (Index < 1) or (Index > (XSize * YSize)) then
    raise EColorArrayIndexError.Create('Array index out of bounds');
  if FColors^[Index] <> Value then
    FColors^[Index] := Value;
end;

procedure TColorArrayClass.CheckXYVals(X, Y: integer);
begin
  if (X < 1) or (Y < 1) or (X > XSize) or (Y > YSize) then
    raise EColorArrayIndexError.Create('Array index out of bounds');
end;


{$IFDEF FIX_STREAM_ERROR}
const
  STREAM_SIG = $DF5;

procedure TColorArrayClass.ReadColorData(Stream: TStream);
var
  Sig: integer;
  X, Y: integer;
  AColor: TColor;
begin
  Stream.ReadBuffer(Sig, sizeof(Sig));
  if Sig = STREAM_SIG then
  begin
    Stream.ReadBuffer(X, sizeof(X));
    XSize := X;
    Stream.ReadBuffer(Y, sizeof(Y));
    YSize := Y;
    for X := 1 to XSize do
      for Y := 1 to YSize do
      begin
        Stream.ReadBuffer(AColor, SizeOf(TColor));
        Color[X, Y] := AColor;
      end;
  end;
end;

procedure TColorArrayClass.WriteColorData(Stream: TStream);
var
  X, Y: integer;
  AColor: TColor;
begin
  X := XSize;
  Stream.WriteBuffer(X, SizeOf(X));
  Y := YSize;
  Stream.WriteBuffer(Y, SizeOf(Y));
  for X := 1 to XSize do
    for Y := 1 to YSize do
    begin
      AColor := Color[X, Y];
      Stream.WriteBuffer(AColor, SizeOf(TColor));
    end;
end;

{$ELSE}

procedure TColorArrayClass.ReadColors(Reader: TReader);
var
  X, Y: integer;
  AColor: TColor;
begin
  XSize := Reader.ReadInteger;
  YSize := Reader.ReadInteger;
  for X := 1 to XSize do
    for Y := 1 to YSize do
    begin
      Reader.Read(AColor, SizeOf(TColor));
      Color[X, Y] := AColor;
    end;
end;

procedure TColorArrayClass.WriteColors(Writer: TWriter);
var
  X, Y: integer;
  AColor: TColor;
begin
  Writer.WriteInteger(XSize);
  Writer.WriteInteger(YSize);
  for X := 1 to XSize do
    for Y := 1 to YSize do
    begin
      AColor := Color[X, Y];
      Writer.Write(AColor, SizeOf(TColor));
    end;
end;

{$ENDIF}

procedure TColorArrayClass.DefineProperties(Filer: TFiler);
begin
  inherited DefineProperties(Filer);
{$IFDEF FIX_STREAM_ERROR}
  Filer.DefineBinaryProperty('SavedColors', ReadColorData, WriteColorData, TRUE);
{$ELSE}
  Filer.DefineProperty('SavedColors', ReadColors, WriteColors, TRUE);
{$ENDIF}
end;

procedure TColorArrayClass.Assign(Source: TPersistent);
var
  x, y: integer;
begin
  if Source is TColorArrayClass then
  begin
    FreeMem(FColors, XSize * YSize * SizeOf(TColor));
    FXSize := TColorArrayClass(Source).XSize;
    FYSize := TColorArrayClass(Source).YSize;
    GetMem(FColors, XSize * YSize * SizeOf(TColor));
    for x := 1 to XSize do
    begin
      for y := 1 to YSize do
      begin
        Color[x,y] := TColorArrayClass(Source).Color[x,y];
      end;
    end;
  end else
    inherited Assign(Source);
end;

function TColorArrayClass.IsEqualTo(OtherColors: TColorArrayClass): boolean;
var
  x, y: integer;
begin
  Result := FALSE;
  if OtherColors = Self then
  begin
    Result := TRUE;
    exit;
  end;
  if OtherColors <> NIL then
  begin
    if (XSize = OtherColors.XSize) and (YSize = OtherColors.YSize) then
    begin
      for x := 1 to XSize do
      begin
        for y := 1 to YSize do
        begin
          if Color[x,y] <> OtherColors.Color[x,y] then
            exit;
        end;
      end;
      Result := TRUE;  { all colors matched }
    end;
  end;
end;





constructor TDFSColorButtonPalette.Create(AOwner: TComponent);
begin
  { Inherited is going to fire FormCreate which needs the colors, so create our
    stuff before calling inherited. }
  FPaletteColors := TColorArrayClass.Create(4,5);
  FCustomColors := TColorArrayClass.Create(8,2);

  inherited Create(AOwner);
end;

destructor TDFSColorButtonPalette.Destroy;
begin
  FPaletteColors.Free;
  FCustomColors.Free;

  inherited Destroy;
end;

procedure TDFSColorButtonPalette.CreateParams(var Params: TCreateParams);
begin
  inherited CreateParams(Params);
{$IFDEF DFS_WIN32}
  Params.Style := Params.Style AND NOT WS_CAPTION;
{$ELSE}
  Params.Style := WS_POPUP or WS_DLGFRAME or DS_MODALFRAME;
{$ENDIF}
end;

procedure TDFSColorButtonPalette.FormClose(Sender: TObject;
  var Action: TCloseAction);
begin
  Action := caFree;
  if assigned(FPaletteClosed) then
    FPaletteClosed(Self);
end;

procedure TDFSColorButtonPalette.FormDeactivate(Sender: TObject);
begin
  Close;
end;

procedure TDFSColorButtonPalette.FormPaint(Sender: TObject);
var
  X, Y: integer;
begin
  for X := 1 to 4 do
  begin
    for Y := 1 to 5 do
    begin
      { Draw color square }
      DrawSquare(X, Y, FPaletteColors[x,y], FALSE);
    end;
  end;

  { Draw seperator line }
  with Canvas do
  begin
    Pen.Color := clBtnShadow;
    MoveTo(2, 93);
    LineTo(ClientWidth - 2, 93);
    Pen.Color := clBtnHighlight;
    MoveTo(2, 94);
    LineTo(ClientWidth - 2, 94);
  end;

  { Draw "other" color }
  DrawSquare(0, 0, FOtherColor, FALSE);

  { Draw the current selection }
  FrameCurrentSquare;
end;

procedure TDFSColorButtonPalette.DrawSquare(X, Y: integer; AColor: TColor; IsFocused: boolean);
begin
  if (X = 0) and (Y = 0) then
  begin
    { other square }
    X := ClientWidth - 18;
    Y := 97;
    AColor := FOtherColor;
  end else if ValidColorIndex(X, Y) then
  begin
    X := (X-1) * 18 + 2;
    Y := (Y-1) * 18 + 2;
  end else
    exit;

  with Canvas do
  begin
    if IsFocused then
      Pen.Color := clBlack
    else
      Pen.Color := clBtnFace;
    MoveTo(X-1,Y-1);
    LineTo(X+16, Y-1);
    LineTo(X+16, Y+16);
    LineTo(X-1, Y+16);
    LineTo(X-1, Y-1);

    if IsFocused then
    begin
      { Draw frame }
      MoveTo(X+1, Y+1);
      LineTo(X+14, Y+1);
      LineTo(X+14, Y+14);
      LineTo(X+1, Y+14);
      LineTo(X+1, Y+1);
      Pen.Color := clWhite;
      MoveTo(X, Y);
      LineTo(X+15, Y);
      LineTo(X+15, Y+15);
      LineTo(X, Y+15);
      LineTo(X, Y);
    end else begin
      Pen.Color := clGray;
      MoveTo(X, Y+15);
      LineTo(X, Y);
      LineTo(X+15, Y);
      Pen.Color := clWhite;
      LineTo(X+15, Y+15);
      LineTo(X, Y+15);
      Pen.Color := clBlack;
      MoveTo(X+1, Y+14);
      LineTo(X+1, Y+1);
      LineTo(X+14, Y+1);
      Pen.Color := RGB(223, 223, 223);
      LineTo(X+14, Y+14);
      LineTo(X+1, Y+14);
    end;

    Brush.Color := AColor;
    FillRect(Rect(X+2, Y+2, X+14, Y+14));
  end;
end;

function ColorEnumProc(Pen: PLogPen; var Colors: array of TColorRef): integer;
   {$IFDEF DFS_WIN32} stdcall; {$ELSE} export; {$ENDIF}
begin
  if Pen^.lopnStyle = PS_SOLID then
  begin
    if Colors[0] < 20 then
    begin
      inc(Colors[0]);
      Colors[Colors[0]] := Pen^.lopnColor;
      Result := 1;
    end else
      Result := 0;
  end else
    Result := 1;
end;

procedure TDFSColorButtonPalette.FormCreate(Sender: TObject);
var
  X, Y: integer;
  Colors: array[0..20] of TColorRef;
  DC: HDC;
begin
  FPreventClose := FALSE;
  FOldAppDeactivate := Application.OnDeactivate;
  Application.OnDeactivate := AppDeactivate;
  FLastFrame := Point(-1,-1);

  DC := GetDC(GetDesktopWindow);
  try
    if GetDeviceCaps(DC, NUMCOLORS) = 16 then
    begin
      { 16 color mode, enum colors to fill array }
      FillChar(Colors, SizeOf(Colors), #0);
      EnumObjects(DC, OBJ_PEN, @ColorEnumProc,
         {$IFDEF DFS_WIN32} LPARAM(@Colors) {$ELSE} @Colors {$ENDIF});
      for X := 1 to 4 do
      begin
        for Y := 1 to 5 do
        begin
          FPaletteColors[X,Y] := Colors[(X-1)*5+Y];
        end;
      end;
    end else begin
      { Lots 'o colors, pick the ones we want. }
      FPaletteColors[1,1] := RGB(255,255,255);
      FPaletteColors[1,2] := RGB(255,0,0);
      FPaletteColors[1,3] := RGB(0,255,0);
      FPaletteColors[1,4] := RGB(0,0,255);
      FPaletteColors[1,5] := RGB(191,215,191);
      FPaletteColors[2,1] := RGB(0,0,0);
      FPaletteColors[2,2] := RGB(127,0,0);
      FPaletteColors[2,3] := RGB(0,127,0);
      FPaletteColors[2,4] := RGB(0,0,127);
      FPaletteColors[2,5] := RGB(159,191,239);
      FPaletteColors[3,1] := RGB(191,191,191);
      FPaletteColors[3,2] := RGB(255,255,0);
      FPaletteColors[3,3] := RGB(0,255,255);
      FPaletteColors[3,4] := RGB(255,0,255);
      FPaletteColors[3,5] := RGB(255,247,239);
      FPaletteColors[4,1] := RGB(127,127,127);
      FPaletteColors[4,2] := RGB(127,127,0);
      FPaletteColors[4,3] := RGB(0,127,127);
      FPaletteColors[4,4] := RGB(127,0,127);
      FPaletteColors[4,5] := RGB(159,159,159);
    end;
  finally
    ReleaseDC(GetDesktopWindow, DC);
  end;

  FOtherColor := clBtnFace;
  FStartColor := clBlack;
end;

procedure TDFSColorButtonPalette.SetStartColor(Value: TColor);
var
  x, y: integer;
begin
  FStartColor := Value;
  { See if we have that color }
  for x := 1 to 4 do
  begin
    for y := 1 to 5 do
    begin
      if ColorToRGB(FPaletteColors[x,y]) = ColorToRGB(FStartColor) then
      begin
        FLastFrame := Point(x,y);
        DrawSquare(x, y, FStartColor, TRUE);
        exit;
      end;
    end;
  end;
  { didn't find it }
  FOtherColor := FStartColor;
end;

procedure TDFSColorButtonPalette.AppDeactivate(Sender: TObject);
begin
  if FPreventClose then
    exit;

  if assigned(FOldAppDeactivate) then
    FOldAppDeactivate(Sender);
  Close;
end;

procedure TDFSColorButtonPalette.btnOtherClick(Sender: TObject);
var
  AColor: TColor;
  c: char;
  p: integer;
  y: integer;
  x: integer;
  z: integer;
  Dlg: TColorDialog;
  ColorPicked: boolean;
begin
  Dlg := TColorDialog.Create(Self);
  try
    FPreventClose := TRUE;
    Dlg.Color := FOtherColor;
    Dlg.Options := [cdFullOpen];
    { set custom colors here }
    for x := 1 to 8 do
    begin
      for y := 1 to 2 do
      begin
        c := Chr((y-1)*8+x + 64);
        Dlg.CustomColors.Add('Color' + c + '=' + IntToHex(CustomColors[x,y], 8));
      end;
    end;
    ColorPicked := Dlg.Execute;
    if ColorPicked then
    begin
      FOtherColor := Dlg.Color;
      { get custom colors here }
      for z := 0 to 15 do
      begin
        p := Pos('=', Dlg.CustomColors[z]);
        AColor := StrToIntDef('$'+Copy(Dlg.CustomColors[z], p+1, 9), clWhite);
        p := Ord(Dlg.CustomColors[z][p-1]) - 64;
        x := (p-1) mod 8 + 1;
        y := (p-1) div 8 + 1;
        CustomColors[x,y] := AColor;
      end;
    end;
  finally
    FPreventClose := FALSE;
    Dlg.Free;
  end;

  if ColorPicked then
  begin
    if assigned(FSetParentColor) then
      FSetParentColor(Self, FOtherColor);
    Close;
  end;
end;

procedure TDFSColorButtonPalette.FormCloseQuery(Sender: TObject;
  var CanClose: Boolean);
begin
  CanClose := not FPreventClose;
end;

function TDFSColorButtonPalette.ValidColorIndex(X, Y: integer): boolean;
begin
  Result := ((X > 0) and (X <= 4) and (Y > 0) and (Y <= 5)) or ((X = 0) and (Y = 0));
end;

procedure TDFSColorButtonPalette.FrameCurrentSquare;

  function ComparePoints(const Pt1, Pt2: TPoint): boolean;
  begin
    Result := ((Pt1.X = Pt2.X) and (Pt1.Y =Pt2.Y));
  end;

var
  NewFrame: TPoint;
  AColor: TColor;
begin
  NewFrame := GetCurrentSquare;
  if not ComparePoints(NewFrame, FLastFrame) and
     ValidColorIndex(NewFrame.X, NewFrame.Y) then
  begin
    { Unframe the last one }
    if ValidColorIndex(FLastFrame.X, FLastFrame.Y) then
    begin
      if ComparePoints(FLastFrame, Point(0,0)) then
        AColor := FOtherColor
      else
        AColor := FPaletteColors[FLastFrame.X, FLastFrame.Y];
      with FLastFrame do
        DrawSquare(X, Y, AColor, FALSE);
    end;

        if ComparePoints(NewFrame, Point(0,0)) then
      AColor := FOtherColor
    else
      AColor := FPaletteColors[NewFrame.X, NewFrame.Y];
    with NewFrame do
      DrawSquare(X, Y, AColor, TRUE);
    FLastFrame := NewFrame;
  end;
end;


procedure TDFSColorButtonPalette.FormMouseMove(Sender: TObject;
  Shift: TShiftState; X, Y: Integer);
begin
  FrameCurrentSquare;
end;

procedure TDFSColorButtonPalette.FormClick(Sender: TObject);
var
  SelectedColorSquare: TPoint;
  AColor: TColor;
begin
  if assigned(FSetParentColor) then
  begin
    SelectedColorSquare := GetCurrentSquare;
    if ValidColorIndex(SelectedColorSquare.X, SelectedColorSquare.Y) then
    begin
      if (SelectedColorSquare.X = 0) and (SelectedColorSquare.Y = 0) then
        AColor := FOtherColor
      else
        AColor := FPaletteColors[SelectedColorSquare.x, SelectedColorSquare.Y];
      FSetParentColor(Self, AColor);
    end;
  end;
  Close;
end;

function TDFSColorButtonPalette.GetCurrentSquare: TPoint;

  function IsOtherColorSquare(Pt: TPoint): boolean;
  begin
    Result := (Pt.X >= ClientWidth-19) and (Pt.X <= ClientWidth-1) and
       (Pt.Y >= 96) and (Pt.Y <= 113);
  end;

var
  CurPos: TPoint;
begin
  GetCursorPos(CurPos);
  CurPos := ScreenToClient(CurPos);
  Result := Point((CurPos.X div 18) + 1, (CurPos.Y div 18) + 1);
  if IsOtherColorSquare(CurPos) then
    Result := Point(0,0)
  else if not ValidColorIndex(Result.X, Result.Y) then
    Result := Point(-1,-1);
end;

procedure TDFSColorButtonPalette.FormKeyPress(Sender: TObject;
  var Key: Char);
begin
  if Key = #27 then
    Close;
end;

procedure TDFSColorButtonPalette.FormDestroy(Sender: TObject);
begin
  Application.OnDeactivate := FOldAppDeactivate;
end;

procedure TDFSColorButtonPalette.SetPaletteColors(Value: TPaletteColors);
begin
  FPaletteColors.Assign(Value);
end;

procedure TDFSColorButtonPalette.SetCustomColors(Value: TCustomColors);
begin
  FCustomColors.Assign(Value);
end;


end.